home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload Trio 2 / Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO / dir30 / drftls.zip / RE-ORDER.LSP < prev    next >
Lisp/Scheme  |  1993-09-25  |  16KB  |  651 lines
  1. ; DrafTools   [Version 1.00] 9/25/93       
  2. ;
  3. ; ***************************************
  4. ; ****  Author:  Owen Wengerd        ****
  5. ; ****                               ****
  6. ; ****  Manu-Soft Computer Services  ****
  7. ; ****  P.O. Box 84                  ****
  8. ; ****  Fredericksburg, OH  44627    ****
  9. ; ****  (216) 695-5903               ****
  10. ; ****  Compu-Serve ID:  71324,3252  ****
  11. ; ***************************************
  12.  
  13.  
  14. (defun C:RE-ORDER (/ 
  15.  
  16.  
  17. ;*** Local Variables ***
  18.  
  19.   attrib_list 
  20.   cnt 
  21.   dcl_id 
  22.   dlg_retcode 
  23.   errflag 
  24.   last_focus 
  25.   oldvar 
  26.   olderr
  27.   reorder_list 
  28.   restore
  29.   ss_attrib
  30.   ss_reorder 
  31.   t1 
  32.   t2 
  33.  
  34.  
  35. ; *** Local Functions ***
  36.  
  37.   errexit
  38.   re-orderx
  39.   add_attrib
  40.   check_edattrib
  41.   clear_err
  42.   dismiss_dialog
  43.   dlg_act
  44.   err
  45.   fpath
  46.   get_default_ip
  47.   get_help
  48.   is_visible
  49.   no_select
  50.   parse_ss
  51.   update_attrib_list
  52.   update_reorder_list
  53.   )
  54.  
  55.  
  56. ; *******************  Function Definitions  ******************
  57.  
  58. (defun errexit (s)
  59.   (princ "\nError:  ")
  60.   (princ s)
  61.   (restore)
  62. )
  63.  
  64. (defun re-orderx ()
  65.   (setvar "SORTENTS" (nth 1 oldvar))
  66.   (setvar "REGENMODE" (nth 2 oldvar))
  67.   (setvar "EXPERT" (nth 3 oldvar))
  68.   (if (/= 1 (setq t1 (logand 3 (nth 4 oldvar))))
  69.     (progn
  70.       (command "_UNDO")
  71.       (if (/= 0 (logand 3 (getvar "UNDOCTL"))) (command "_C"))
  72.       (command (if (= 0 t1) "_N" "_O"))
  73.     )
  74.   )
  75.   (setvar "CMDECHO" (car oldvar))
  76.   (setq *error* olderr)
  77.   (princ)
  78. )
  79.  
  80. (defun dlg_act (key why value / t1 t2 t3 cnt)
  81.   (cond
  82.     ( (and errflag (/= errflag key)) 
  83.     )
  84.     ( (= key "get")   
  85.       (if
  86.         (add_attrib (ssget "X" '((0 . "ATTDEF"))))
  87.         (update_attrib_list nil)
  88.       )
  89.     )
  90.     ( (= key "selection")
  91.       (setq ss_attrib value)
  92.       (update_attrib_list T)
  93.     )
  94.     ( (= key "new_order")
  95.       (setq ss_reorder value)
  96.       (update_reorder_list T)
  97.     )
  98.     ( (= key "all")  
  99.       (setq t1  ""
  100.             cnt (length attrib_list)
  101.       )
  102.       (setq ss_attrib
  103.         (repeat cnt 
  104.           (setq cnt (1- cnt))
  105.           (setq t1 (strcat t1 " " (itoa cnt)))
  106.         )
  107.       )
  108.       (update_attrib_list nil)
  109.     )
  110.     ( (= key "none")
  111.       (setq ss_attrib "")
  112.       (update_attrib_list nil)
  113.     )
  114.     ( (= key "ro_all")  
  115.       (setq t1  ""
  116.             cnt (length reorder_list)
  117.       )
  118.       (setq ss_reorder
  119.         (repeat cnt 
  120.           (setq cnt (1- cnt))
  121.           (setq t1 (strcat t1 " " (itoa cnt)))
  122.         )
  123.       )
  124.       (update_reorder_list nil)
  125.     )
  126.     ( (= key "ro_none")
  127.       (setq ss_reorder "")
  128.       (update_reorder_list nil)
  129.     )
  130.     ( (= key "erase")
  131.       (if 
  132.         (and (setq t2 (new_dialog "ERASE" dcl_id)) (= 1 (start_dialog)))
  133.         (done_dialog 5)
  134.         (if (not t2) 
  135.           (alert "Child Dialog Box 'ERASE' Cannot Initialize")
  136.         )
  137.       )
  138.     )
  139.     ( (= key "add")
  140.       (setq t2 (length reorder_list))
  141.       (foreach ent 
  142.         (setq t1 (parse_ss ss_attrib))
  143.         (if (not (member (setq cnt (nth ent attrib_list)) reorder_list))
  144.           (setq reorder_list 
  145.             (append reorder_list (list cnt))
  146.           )
  147.         )
  148.       )
  149.       (setq attrib_list (remove_list attrib_list t1))
  150.       (setq ss_attrib "")
  151.       (update_attrib_list nil)
  152.       (if (< t2 (setq cnt (length reorder_list)))
  153.         (progn
  154.           (setq t1  "")
  155.           (setq ss_reorder
  156.             (repeat (- cnt t2) 
  157.               (setq cnt (1- cnt))
  158.               (setq t1 (strcat t1 " " (itoa cnt)))
  159.             )
  160.           )
  161.           (update_reorder_list nil)
  162.         )
  163.       )
  164.       (mode_tile "new_order" 2)
  165.     )
  166.     ( (= key "insert")
  167.       (setq 
  168.         t3   
  169.            (if reorder_list
  170.              (member 
  171.                (setq t1 (nth (atoi ss_reorder) reorder_list)) 
  172.                reorder_list
  173.              )
  174.            )
  175.         reorder_list (reverse (cdr (member t1 (reverse reorder_list))))
  176.         t2 (length reorder_list)
  177.       )
  178.       (foreach ent 
  179.         (setq t1 (parse_ss ss_attrib))
  180.         (if 
  181.           (and
  182.             (not (member (setq cnt (nth ent attrib_list)) reorder_list))
  183.             (not (member cnt t3))
  184.           )
  185.           (setq reorder_list 
  186.             (append reorder_list (list cnt))
  187.           )
  188.         )
  189.       )
  190.       (setq attrib_list (remove_list attrib_list t1))
  191.       (setq ss_attrib "")
  192.       (update_attrib_list nil)
  193.       (setq cnt (length reorder_list)
  194.             reorder_list (append reorder_list t3)
  195.       )
  196.       (if (< t2 cnt)
  197.         (progn
  198.           (setq t1  "")
  199.           (setq ss_reorder
  200.             (repeat (- cnt t2) 
  201.               (setq cnt (1- cnt))
  202.               (setq t1 (strcat t1 " " (itoa cnt)))
  203.             )
  204.           )
  205.           (update_reorder_list nil)
  206.         )
  207.       )
  208.       (mode_tile "new_order" 2)
  209.     )
  210.     ( (= key "remove")
  211.       (setq t2 (length attrib_list))
  212.       (foreach ent 
  213.         (setq t1 (parse_ss ss_reorder))
  214.         (if (not (member (setq cnt (nth ent reorder_list)) attrib_list))
  215.           (setq attrib_list 
  216.             (append attrib_list (list cnt))
  217.           )
  218.         )
  219.       )
  220.       (setq reorder_list (remove_list reorder_list t1))
  221.       (setq ss_reorder "")
  222.       (update_reorder_list nil)
  223.       (if (< t2 (setq cnt (length attrib_list)))
  224.         (progn
  225.           (setq t1  "")
  226.           (setq ss_attrib
  227.             (repeat (- cnt t2)
  228.               (setq cnt (1- cnt))
  229.               (setq t1 (strcat t1 " " (itoa cnt)))
  230.             )
  231.           )
  232.           (update_attrib_list nil)
  233.         )
  234.       )
  235.       (mode_tile "selection" 2)
  236.     )
  237.     ( (= key "reverse")
  238.       (if (no_select ss_attrib)
  239.         (progn
  240.           (setq t2 ""
  241.                 t1 (length attrib_list)
  242.           )
  243.           (foreach cnt (parse_ss ss_attrib)
  244.             (setq t2 (strcat t2 " " (itoa (- t1 cnt 1))))
  245.           )
  246.           (setq ss_attrib t2)
  247.         )
  248.       )
  249.       (setq attrib_list (reverse attrib_list))
  250.       (update_attrib_list nil)
  251.     )
  252.     ( (= key "clear")
  253.       (setq attrib_list (remove_list attrib_list (parse_ss ss_attrib)))
  254.       (setq ss_attrib "")
  255.       (update_attrib_list nil)
  256.       (mode_tile "selection" 2)
  257.     )
  258.   )
  259.   (if errflag (mode_tile errflag 2) (setq last_focus key))
  260. )
  261.  
  262. (defun clear_err ()
  263.   (set_tile "error" "")
  264.   (setq errflag nil)
  265. )
  266.  
  267. (defun err (msg key)
  268.   (set_tile "error" msg)
  269.   (setq errflag key)
  270. )     
  271.  
  272. (defun is_visible (pt)
  273.   (if
  274.     (and
  275.       pt
  276.       (listp pt)
  277.       (<= 
  278.         (abs (- (car (getvar "VIEWCTR")) (car pt))) 
  279.         (* (getvar "VIEWSIZE") (apply '/ (getvar "SCREENSIZE")) 0.5)
  280.       )
  281.       (<=
  282.         (abs (- (cadr (getvar "VIEWCTR")) (cadr pt)))
  283.         (/ (getvar "VIEWSIZE") 2)
  284.       )
  285.     )
  286.     pt
  287.   )
  288. )
  289.  
  290. (defun get_default_ip (ent / pt)
  291.   (if
  292.     (or
  293.       (and ent (setq pt (cdr (assoc '10 (entget ent)))))
  294.       (setq pt (is_visible '(0 0 0)))
  295.       (setq pt (is_visible (getvar "LASTPOINT")))
  296.     )
  297.     pt
  298.     (getvar "VIEWCTR")
  299.   )
  300. )
  301.  
  302. (defun no_select (ss)
  303.   (and ss (/= ss "") (not (wcmatch ss " ")))
  304. )
  305.  
  306. (defun check_edattrib (retcode / t1)
  307.   (if 
  308.     (or 
  309.       (= 'LIST (type edattrib)) 
  310.       (and 
  311.         (setq t1 (fpath "EDATTRIB.LSP")) 
  312.         (load t1) 
  313.         (= 'LIST (type edattrib))
  314.       )
  315.     )
  316.     (done_dialog retcode)
  317.     (alert
  318.       (if t1 
  319.         "Function 'EDATTRIB' is not defined\n     in file 'EDATTRIB.LSP'"
  320.         "Cannot find file 'EDATTRIB.LSP' in\n       current search path"
  321.       )
  322.     )
  323.   )
  324. )
  325.  
  326. (defun parse_ss (ss / ret)
  327.   (if (no_select ss)
  328.     (progn
  329.       (while (/= ss "")    
  330.         (setq ret (cons (atoi ss) ret))
  331.         (while (and (/= ss "") (= " " (substr ss 1 1)))
  332.           (setq ss (substr ss 2))
  333.         )
  334.         (while (and (/= ss "") (/= " " (substr ss 1 1)))
  335.           (setq ss (substr ss 2))
  336.         )
  337.       )
  338.       (reverse ret)
  339.     )
  340.   )
  341. )
  342.  
  343. (defun remove_list (lst xentlist / t1)
  344.   (foreach ent
  345.     xentlist
  346.     (setq lst (subst nil (nth ent lst) lst))
  347.   )
  348.   (foreach ent lst (if ent (setq t1 (append t1 (list ent)))))
  349.   t1
  350. )
  351.  
  352. (defun fpath (filename / path)
  353.   (if 
  354.     (and
  355.       *DT_PATH 
  356.       (setq path
  357.         (findfile 
  358.           (strcat 
  359.             *DT_PATH 
  360.             (if (= "\\" (substr *DT_PATH (strlen *DT_PATH) 1)) "" "\\") 
  361.             filename
  362.           )
  363.         )
  364.       )
  365.     )
  366.     path
  367.     (findfile filename)
  368.   )
  369. )
  370.  
  371. (defun add_attrib (set / t1 cnt len)
  372.   (setq len (length attrib_list))
  373.   (if set
  374.     (progn  
  375.       (setq cnt (1- (sslength set)))
  376.       (while (>= cnt 0)
  377.         (if (not (assoc (setq t1 (ssname set cnt)) attrib_list))
  378.           (setq attrib_list 
  379.             (append attrib_list 
  380.               (list 
  381.                 (cons
  382.                   t1 
  383.                   (cdr (assoc '2 (entget t1)))
  384.                 )
  385.               )
  386.             )
  387.           )
  388.         )
  389.         (setq cnt (1- cnt))
  390.       )
  391.       (setq t1  ""
  392.             cnt (length attrib_list)
  393.       )
  394.       (setq ss_attrib
  395.         (repeat (- cnt len)
  396.           (setq cnt (1- cnt))
  397.           (setq t1 (strcat t1 " " (itoa cnt)))
  398.         )
  399.       )
  400.     )
  401.   )
  402.   (/= len (length attrib_list))
  403. )
  404.  
  405. (defun update_attrib_list (only_selection / t1)
  406.   (if attrib_list
  407.     (progn
  408.       (if (not only_selection)
  409.         (progn
  410.           (start_list "selection")
  411.           (foreach t1 attrib_list (add_list (cdr t1)))
  412.           (end_list)
  413.         )
  414.       )
  415.       (if (no_select ss_attrib)
  416.         (progn
  417.           (set_tile "selection" ss_attrib)
  418.           (setq ss_attrib (get_tile "selection"))
  419.           (set_tile "sslength" 
  420.             (itoa (setq t1 (length (parse_ss ss_attrib))))
  421.           )
  422.           (mode_tile "edit" (if (= 1 t1) 0 1))
  423.           (foreach t1 
  424.             '("erase" "insert" "add" "clear")
  425.             (mode_tile t1 0)
  426.           )
  427.         )
  428.         (progn
  429.           (set_tile "selection" "")
  430.           (set_tile "sslength" "None")
  431.           (foreach t1 
  432.             '("edit" "erase" "insert" "add" "clear")
  433.             (mode_tile t1 1)
  434.           )
  435.         )
  436.       )
  437.       (foreach t1 '("all" "none" "reverse") (mode_tile t1 0))
  438.     )
  439.     (progn
  440.       (start_list "selection")
  441.       (end_list)
  442.       (foreach t1 
  443.         '("edit" "erase" "insert" "add" "all" "none" "reverse" "clear")
  444.         (mode_tile t1 1)
  445.       )
  446.       (set_tile "sslength" "None")
  447.     )
  448.   )
  449. )
  450.  
  451. (defun update_reorder_list (only_selection / t1)
  452.   (if reorder_list
  453.     (progn
  454.       (if (not only_selection)
  455.         (progn
  456.           (start_list "new_order")
  457.           (foreach t1 reorder_list (add_list (cdr t1)))
  458.           (end_list)
  459.         )
  460.       )
  461.       (if (no_select ss_reorder)
  462.         (progn
  463.           (set_tile "new_order" ss_reorder)
  464.           (setq ss_reorder (get_tile "new_order"))
  465.           (set_tile "ro_length" 
  466.             (itoa (length (parse_ss ss_reorder)))
  467.           )
  468.           (mode_tile "remove" 0)
  469.         )
  470.         (progn
  471.           (set_tile "ro_length" "None")
  472.           (set_tile "new_order" "")
  473.           (mode_tile "remove" 1)
  474.         )
  475.       )
  476.       (foreach t1 
  477.         '("ro_all" "ro_none" "re-order" "new_order")
  478.         (mode_tile t1 0)
  479.       )
  480.     )
  481.     (progn
  482.       (start_list "new_order")
  483.       (end_list)
  484.       (foreach t1 
  485.         '("ro_all" "ro_none" "re-order" "new_order" "remove")
  486.         (mode_tile t1 1)
  487.       )
  488.       (set_tile "ro_length" "None")
  489.     )
  490.   )
  491. )
  492.  
  493. (defun get_help (/ help_path)
  494.   (if (setq help_path (fpath "RE-ORDER.HLP"))
  495.     (acad_helpdlg help_path "")
  496.     (alert "Cannot locate help file 'RE-ORDER.HLP'!")
  497.   )
  498.   (mode_tile (if errflag errflag last_focus) 2)
  499. )
  500.  
  501. (defun dismiss_dialog (retcode)
  502.   (if errflag
  503.     (mode_tile errflag 2)  
  504.     (done_dialog retcode)
  505.   )
  506. )
  507.  
  508.  
  509. ; ********************************************************
  510. ; ********************  MAIN PROGRAM  ********************
  511. ; ********************************************************
  512.  
  513.   (setq T (not nil))
  514.   (if 
  515.     (setq dcl_id (if (setq t1 (fpath "RE-ORDER.DCL")) (load_dialog t1)))
  516.     (progn
  517.       (setq oldvar
  518.         (list
  519.           (getvar "CMDECHO")
  520.           (getvar "SORTENTS")
  521.           (getvar "REGENMODE")
  522.           (getvar "EXPERT")
  523.           (getvar "UNDOCTL")
  524.         )
  525.       )
  526.       (setq olderr  *error*
  527.             restore re-orderx
  528.             *error* errexit
  529.       )
  530.       (setvar "CMDECHO" 0)
  531.       (setvar "REGENMODE" 1)
  532.       (setvar "EXPERT" 0)
  533.       (if (/= 1 (setq t1 (logand 3 (getvar "UNDOCTL"))))
  534.         (progn
  535.           (command "_UNDO") 
  536.           (if (/= 0 t1) (command "_C")) 
  537.           (command "_A")
  538.         )
  539.       )
  540.       (setvar "SORTENTS" (logior 1 (getvar "SORTENTS")))
  541.       (terpri)
  542.       (setq dlg_retcode   6
  543.             last_focus    "selection"
  544.       )
  545.       (while (and (> dlg_retcode 1) (new_dialog "RE_ORDER" dcl_id))
  546.         (update_attrib_list nil)
  547.         (update_reorder_list nil)
  548.         (if (not (ssget "X" '((0 . "ATTDEF"))))
  549.           (progn
  550.             (mode_tile "select" 1)
  551.             (mode_tile "get" 1)
  552.           )
  553.         )
  554.         (action_tile "help" "(get_help)")
  555.         (action_tile "select" "(dismiss_dialog 2)")
  556.         (action_tile "accept" "(done_dialog 1)")
  557.         (action_tile "cancel" "(done_dialog 0)")
  558.         (action_tile "edit" "(check_edattrib 4)")
  559.         (action_tile "new" "(check_edattrib 3)")
  560.         (foreach t1
  561.           '("get"          "selection"    "all"          "none"         
  562.             "insert"       "remove"       "add"          "new_order"    
  563.             "ro_all"       "ro_none"      "erase"        "reverse"
  564.             "clear"
  565.           )
  566.           (action_tile t1 "(dlg_act $key $reason $value)")
  567.         )
  568.         (if last_focus (mode_tile last_focus 2))
  569.         (setq dlg_retcode (start_dialog))
  570.         (cond
  571.           ( (= 0 dlg_retcode))
  572.           (
  573.             (= 2 dlg_retcode)
  574.             (add_attrib (ssget '((0 . "ATTDEF"))))
  575.             (princ "\nReturning to Dialog Box\n \n ")
  576.             (setq last_focus "select")
  577.           )
  578.           (
  579.             (= 3 dlg_retcode)
  580.             (command 
  581.               cancel
  582.               cancel
  583.               "_ATTDEF"
  584.               ""
  585.               "???"
  586.               ""
  587.               ""
  588.               (get_default_ip nil)
  589.               ""
  590.               ""
  591.             )
  592.             (if (= 1 (edattrib (entlast)))
  593.               (setq attrib_list 
  594.                 (append attrib_list 
  595.                   (list (cons (entlast) (cdr (assoc '2 (entget (entlast))))))
  596.                 )
  597.               )
  598.               (command "_U")
  599.             )
  600.             (princ "\nReturning to Dialog Box\n \n ")
  601.           )
  602.           (
  603.             (= 4 dlg_retcode)
  604.             (edattrib (setq t1 (car (nth (atoi ss_attrib) attrib_list))))
  605.             (setq attrib_list
  606.               (subst 
  607.                 (cons t1 (cdr (assoc '2 (entget t1)))) 
  608.                 (assoc t1 attrib_list) 
  609.                 attrib_list
  610.               )
  611.             )
  612.             (princ "\nReturning to Dialog Box\n \n ")
  613.           )
  614.           (
  615.             (= 5 dlg_retcode)
  616.             (setq t2 (ssadd))
  617.             (foreach ent 
  618.               (setq t1 (parse_ss ss_attrib))
  619.               (ssadd (car (nth ent attrib_list)) t2)
  620.             )
  621.             (command "_ERASE" t2 "")
  622.             (setq attrib_list (remove_list attrib_list t1))
  623.             (setq ss_attrib "")
  624.           )
  625.           (T 
  626.             (if reorder_list
  627.               (progn
  628.                 (command "_BLOCK" 
  629.                           "TEMP" 
  630.                 )
  631.                 (if (tblsearch "BLOCK" "TEMP") (command "_Y"))
  632.                 (command '(0 0)) 
  633.                 (foreach t1 reorder_list (command (car t1))) 
  634.                 (command "" "_INSERT" "*TEMP" '(0 0) 1 0)
  635.               )
  636.             )
  637.           )
  638.         )
  639.       )
  640.       (unload_dialog dcl_id)
  641.       (restore)
  642.     )
  643.     (alert 
  644.       (strcat 
  645.         "Dialog Box Definition File 'EDATTRIB.DCL' not Found"
  646.         "\n                Cannot Continue!"
  647.       )
  648.     )
  649.   )
  650. )
  651.